Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/forms/frmwiz/rdblib/rdblib.bas

BASIC Source File | 1995-01-02 | 16KB | 417 lines

' Common Subroutine & Functions Module
' Provided by:
'    Royce D. Bacon
'    RDB Systems
'    8942 W. Lawrence Ave.
'    Milwaukee, WI  53225
'    Compuserve ID: 70042,1001
'
' You may use these routines in your own programs and
' distribute them or the compiled versions of them
' with your programs.  However, you may not distribute
' these routines alone for profit.
'
' Payment for these routines is not required, but will
' always be appreciated.
'


Global rb_systemname As String
Global rb_version As String
Global RB_Erraction As Integer
Global Const RB_GRAY = &HC0C0C0
' Constants, etc. for screen capture/print function
Global Const SW_HIDE = 0
Global Const SW_SHOW = 5
Declare Function ShowWindow Lib "User" (ByVal hwnd As Integer, ByVal nCmdShow As Integer) As Integer


' Windows function declarations

Declare Function GetModuleUsage Lib "KERNEL" (ByVal InstanceID%) As Integer

'******************************************************
'           DLL Declarations                          *
'******************************************************
Type POINTAPI
    X As Integer
    Y As Integer
End Type

Declare Function LoadMenu Lib "User" (ByVal hInstance As Integer, ByVal lpString As String) As Integer
Declare Function GetMenu Lib "User" (ByVal hwnd As Integer) As Integer
Declare Function SetMenu Lib "User" (ByVal hwnd As Integer, ByVal hMenu As Integer) As Integer
Declare Function HiliteMenuItem Lib "User" (ByVal hwnd As Integer, ByVal hMenu As Integer, ByVal wIDHiliteItem As Integer, ByVal wHilite As Integer) As Integer
Declare Function GetMenuString Lib "User" (ByVal hMenu As Integer, ByVal wIDItem As Integer, ByVal lpString As String, ByVal nMaxCount As Integer, ByVal wFlag As Integer) As Integer
Declare Function GetMenuState Lib "User" (ByVal hMenu As Integer, ByVal wId As Integer, ByVal wFlags As Integer) As Integer
Declare Sub DrawMenuBar Lib "User" (ByVal hwnd As Integer)
Declare Function GetSystemMenu Lib "User" (ByVal hwnd As Integer, ByVal bRevert As Integer) As Integer
Declare Function GetSubMenu Lib "User" (ByVal hMenu As Integer, ByVal nPos As Integer) As Integer
Declare Function GetMenuItemID Lib "User" (ByVal hMenu As Integer, ByVal nPos As Integer) As Integer
Declare Function GetMenuItemCount Lib "User" (ByVal hMenu As Integer) As Integer
Declare Function TrackPopupMenu Lib "User" (ByVal hMenu As Integer, ByVal wFlags As Integer, ByVal X As Integer, ByVal Y As Integer, ByVal nReserved As Integer, ByVal hwnd As Integer, lpReserved As Any) As Integer
Declare Function InsertMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer, ByVal wIDNewItem As Integer, ByVal lpNewItem As Any) As Integer
Declare Function AppendMenu Lib "User" (ByVal hMenu As Integer, ByVal wFlags As Integer, ByVal wIDNewItem As Integer, ByVal lpNewItem As Any) As Integer
Declare Function ModifyMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer, ByVal wIDNewItem As Integer, ByVal lpString As Any) As Integer
Declare Function RemoveMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer
Declare Function DeleteMenu Lib "User" (ByVal hMenu As Integer, ByVal nPosition As Integer, ByVal wFlags As Integer) As Integer

Declare Function ExitWindows Lib "User" (ByVal dwReserved As Long, wReturnCode) As Integer
Declare Function GetDeviceCaps Lib "GDI" (ByVal hDC As Integer, ByVal nIndex As Integer) As Integer
Declare Function GetActiveWindow Lib "User" () As Integer
Declare Sub GetCursorPos Lib "User" (lpPoint As POINTAPI)
Declare Function GetSystemMetrics Lib "User" (ByVal nIndex As Integer) As Integer
Declare Function GetFocus Lib "User" () As Integer
Declare Function SetActiveWindow Lib "User" (ByVal hwnd As Integer) As Integer
Declare Function GetModuleHandle Lib "Kernel" (ByVal lpModuleName As String) As Integer
Declare Function GetModuleFileName Lib "Kernel" (ByVal hModule As Integer, ByVal lpFilename As String, ByVal nSize As Integer) As Integer
Declare Function GetFreeSpace Lib "Kernel" (ByVal wFlags As Integer) As Long

'Indices for GetSystemMetrics
Global Const SM_CXSIZE = 30
Global Const SM_CYSIZE = 31

'Indices for GetDeviceCaps
Global Const HORZRES = 8    '  Horizontal width in pixels
Global Const VERTRES = 10   '  Vertical width in pixels

'Menu flags for Add/Check/EnableMenuItem()
Global Const MF_INSERT = &H0
Global Const MF_CHANGE = &H80
Global Const MF_APPEND = &H100
Global Const MF_DELETE = &H200
Global Const MF_REMOVE = &H1000

Global Const MF_BYCOMMAND = &H0
Global Const MF_BYPOSITION = &H400

Global Const MF_SEPARATOR = &H800

Global Const MF_ENABLED = &H0
Global Const MF_GRAYED = &H1
Global Const MF_DISABLED = &H2

Global Const MF_UNCHECKED = &H0
Global Const MF_CHECKED = &H8
Global Const MF_USECHECKBITMAPS = &H200

Global Const MF_STRING = &H0
Global Const MF_BITMAP = &H4
Global Const MF_OWNERDRAW = &H100

Global Const MF_POPUP = &H10
Global Const MF_MENUBARBREAK = &H20
Global Const MF_MENUBREAK = &H40

Global Const MF_UNHILITE = &H0
Global Const MF_HILITE = &H80

Global Const MF_SYSMENU = &H2000
Global Const MF_HELP = &H4000
Global Const MF_MOUSESELECT = &H8000

'  Menu item resource format
Type MENUITEMTEMPLATEHEADER
    versionNumber As Integer
    offset As Integer
End Type

Type MENUITEMTEMPLATE
    mtOption As Integer
    mtID As Integer
    mtString As Long
End Type

Global Const MF_END = &H80

'  System Menu Command Values
Global Const SC_SIZE = &HF000
Global Const SC_MOVE = &HF010
Global Const SC_MINIMIZE = &HF020
Global Const SC_MAXIMIZE = &HF030
Global Const SC_NEXTWINDOW = &HF040
Global Const SC_PREVWINDOW = &HF050
Global Const SC_CLOSE = &HF060
Global Const SC_VSCROLL = &HF070
Global Const SC_HSCROLL = &HF080
Global Const SC_MOUSEMENU = &HF090
Global Const SC_KEYMENU = &HF100
Global Const SC_ARRANGE = &HF110
Global Const SC_RESTORE = &HF120
Global Const SC_TASKLIST = &HF130

'******************************************************
'*          OpenFile Modes                            *
'******************************************************
Global Const REPLACEFILE = 0
Global Const READFILE = 1
Global Const APPENDFILE = 2
Global Const RANDOMFILE = 3
Global Const BINARYFILE = 4


'**************************************************
' Declares for screen grabber function
'**************************************************
Type lrect
    Left As Integer
    Top As Integer

    right As Integer
    bottom As Integer
End Type
Declare Function GetDesktopWindow Lib "user" () As Integer
Declare Function GetDC Lib "user" (ByVal hwnd%) As Integer

' Note: The following Declare should be on one line:
Declare Function BitBlt Lib "GDI" (ByVal hDestDC%, ByVal X%, ByVal Y%, ByVal nWidth%, ByVal nHeight%, ByVal hSrcDC%, ByVal XSrc%, ByVal YSrc%, ByVal dwRop&) As Integer
Declare Function ReleaseDC Lib "User" (ByVal hwnd As Integer, ByVal hDC As Integer) As Integer

Declare Sub GetWindowRect Lib "User" (ByVal hwnd%, lpRect As lrect)
Global TwipsPerPixel As Single


'Other API Declarations For Sound
Declare Sub MessageBeep Lib "User" (ByVal wType As Integer)
Declare Sub SndPlaySound Lib "MMSystem.dll" (ByVal WavFile$, ByVal wFlags As Integer)

Sub Form3D (formname As Form)
   ' This code came from Visual Basic Tips And Techniques 94
   ' Tip Submitted By: Matej Nastran
   ' Modified to set 3-D based upon control type instead of tag = 3-D
   Dim drkgray As Long, fullwhite As Long
   Dim i As Integer, dw As Integer, Do3D As Integer
   Dim ctop As Integer, cleft As Integer, cright As Integer, cbottom As Integer

    ' Outline a form's text and combobox controls for 3D look

    Dim cname As Control

    drkgray = RGB(128, 128, 128)
    fullwhite = RGB(255, 255, 255)

    dw = formname.DrawWidth
    formname.DrawWidth = 1      'this suits me best
    For i = 0 To (formname.Controls.Count - 1)
        Set cname = formname.Controls(i)
        If TypeOf cname Is TextBox Then
            Do3D = True
        ElseIf TypeOf cname Is ComboBox Then
            Do3D = True
        Else
            Do3D = False
        End If
        If Do3D Then
            ctop = cname.Top - Screen.TwipsPerPixelY
            cleft = cname.Left - Screen.TwipsPerPixelX
            cright = cname.Left + cname.Width
            cbottom = cname.Top + cname.Height
            formname.Line (cleft, ctop)-(cright, ctop), drkgray
            formname.Line (cleft, ctop)-(cleft, cbottom), drkgray
            formname.Line (cleft, cbottom)-(cright, cbottom), fullwhite
            formname.Line (cright, ctop)-(cright, cbottom), fullwhite
        End If
    Next i
    formname.DrawWidth = dw
End Sub

Sub RB_Center (str_to_print As String, line_no, skip_line As Integer)
    ' ============= RB_Center ==============================
    ' Will center a string passed as parameter 1
    ' on printer line passed as parameter 2 or current line if parameter 2 = 0
    ' Will skip to next line if parameter 3 = true
    ' e.g. RB_Center "This String Will Be Centered On Line 3", 3, true
    '
    Dim col_to_print_at As Single
    col_to_print_at = ((printer.ScaleWidth - printer.TextWidth(str_to_print)) / 2) + printer.ScaleLeft
    printer.CurrentX = col_to_print_at
    If line_no <> 0 Then
        printer.CurrentY = line_no
    End If
    If skip_line Then
        printer.Print str_to_print
    Else
        printer.Print str_to_print;
    End If

End Sub

Function RB_ErrorHandler (pform As String, proutine As String) As Integer
    ' =================== RB_ErrorHandler =========================
    ' Displays dialog indicating error and allows user to
    ' print problem report form, obtain help on error condition,
    ' abort program, retry the function, or ignore the error
    '
    ' Example of using RB_ErrorHandler
    ' erraction = RB_ErrorHandler("FormName", "Routine")
    ' Select Case erraction
    ' Case 1
    '     Resume 0      ' Retry option selected
    ' Case 2
    '     Resume Next   ' Ignore option selected
    ' End Select
    '
    ' To use in your projects include RDBLIB.BAS, RBERRFRM.FRM,
    ' RBPROBRP.FRM, RBSCRN.FRM

    Dim RB_err As Integer
    Dim RB_error As String
    Dim RB_errl As Long
    Dim RB_Msg As String
    RB_err = Err
    RB_error = Error$
    RB_errl = Erl
    SndPlaySound "crash.wav", 2
    Beep
    RB_Msg = "A " & RB_error & " error (" & RB_err & ") has occurred"
    If RB_errl <> 0 Then
        RB_Msg = RB_Msg & " at line " & RB_errl
    End If
    RB_Msg = RB_Msg + " in routine " & proutine & " of form " & pform
    RB_Msg = RB_Msg & "."
    If RB_err = 3051 Then
        RB_Msg = RB_Msg & "  This error is usually caused because another user on the network, "
        RB_Msg = RB_Msg & "another function on this workstation, is performing a function that "
        RB_Msg = RB_Msg & "requires exclusive use of the indicated file."
    End If
    RBErrFrm.Msg.Text = RB_Msg
    RBErrFrm.SvErr.Caption = RB_err
    RBErrFrm.Show MODAL
    Select Case RB_Erraction
    Case 0
        End
    Case 1
        RB_ErrorHandler = RB_Erraction
    Case 2
        RB_ErrorHandler = RB_Erraction
    End Select

End Function

Function RB_Rjustify (pnumber, pformat As String, pcol) As Single
    ' ========================= RB_Rjustify ====================
    ' Will print a number passed as parameter 1
    ' according to the format passed as parameter 2
    ' right justified on the column passed as parameter 3
    ' Returns the leftmost column position where printing started
    '
    ' Example:
    ' leftcol = RB_Rjustify(200, "###,###.##", 40)
    ' will print "    200.00" with the rightmost 0 at column 40
    '
    Dim rbpos As Single
    Dim rbstr As String
    Dim rblen As Single
    rbstr = Format$(pnumber, pformat)
    rblen = printer.TextWidth(rbstr)
    rbpos = pcol - rblen
    printer.CurrentX = rbpos
    printer.Print rbstr;
    RB_Rjustify = rbpos

End Function

Function RB_Text_Format (instring As String, pwidth As Long)
    ' ==================== RB_Text_Format ===================
    ' Will return a string variable passed as parameter 1
    ' formatted to print with a line length of parameter 2
    ' It will break each line at the end of a word
    '
    ' Example:
    ' newstring = RB_Text_Format(oldstring, 65)
    ' Printer.Print newstring
    ' will print the contents of oldstring as 65 character lines
    '
    Dim startpos As Integer, nextrtn As Integer, nextspace As Integer
    Dim svstatpos As Integer, svwkstring As String, wkinstring As String
    Dim wkstring As String, outstring As String, gotstring As Integer
    outstring = ""
    wkinstring = Trim$(instring)
    nextrtn = 0
    startpos = 1
    Do While startpos < Len(wkinstring)
        gotstring = False
        nextrtn = InStr(startpos, wkinstring, Chr$(13))
        If nextrtn > 0 Then
            wkstring = Mid$(wkinstring, startpos, nextrtn - startpos + 1)
            ' Check for string less than 400 characters because long
            ' strings cause an overflow error and definitely won't fit
            ' on a single line
            If Len(wkstring) < 400 Then
                If printer.TextWidth(wkstring) < pwidth Then
                    outstring = outstring + wkstring
                    startpos = nextrtn + 2
                    gotstring = True
                End If
            End If
        End If
        If Not gotstring Then
            wkstring = ""
            Do
                svwkstring = wkstring
                svstartpos = startpos
                nextrtn = InStr(startpos, wkinstring, " ")
                If nextrtn = 0 Then
                    wkstring = wkstring + Mid$(wkinstring, startpos)
                    svwkstring = wkstring
                    startpos = Len(wkinstring) + 1
                    svstartpos = startpos
                Else
                    wkstring = wkstring + Mid$(wkinstring, startpos, nextrtn - startpos + 1)
                    startpos = nextrtn + 1
                End If
            Loop While printer.TextWidth(wkstring) <= pwidth And startpos <= Len(wkinstring)
            startpos = svstartpos
            outstring = outstring + svwkstring + Chr$(13) + Chr$(10)
        End If
    Loop
    RB_Text_Format = outstring


End Function

Function RB_Validate_Date (cdate As Control) As Integer
    ' ================= RB_Validate_Date =====================
    ' validates date contained in control passed as parameter 1
    ' will return True if input is valid date, the string "__/__/__" or null
    ' will display a msgbox with an "Enter a valid data" msg and return False
    '      if the input date is invalid
    '
    ' Example:
    ' TxtDate_LostFocus
    '   IF Not RB_Validate_Date(TxtDate) then
    '       Date.setfocus
    '   End If
    '
    Dim wk_date As String
    wk_date = cdate.Text
    If wk_date = "__/__/__" Or wk_date = "" Then
        RB_Validate_Date = True
        cdate.Text = ""
    ElseIf Not IsDate(wk_date) Then
        Beep
        MsgBox "Enter a valid date", , "Date Entry Error"
        RB_Validate_Date = False
    Else
        RB_Validate_Date = True
    End If

End Function

Sub ShellAndWait (CommandString$)
  ' ============== ShellAndWait =====================
  ' Will start (via Shell Function) the command passed as parameter 1
  ' and wait until the command has completed and the window closed
  '
  ' Example:
  ' ShellAndWait("COPY A.TXT B.TXT")
  ' B.TXT will be available now
  '
  ID% = Shell(CommandString$, 3)
  Do
    X% = DoEvents()
  Loop Until GetModuleUsage(ID%) = 0

End Sub